home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / interrupt.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  73 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Interrupts
  5.  
  6. (define interrupt-handlers
  7.   (make-vector interrupt-count 0))
  8.  
  9. (do ((i 0 (+ i 1)))
  10.     ((= i interrupt-count))
  11.   (vector-set! interrupt-handlers i
  12.            (lambda (enabled-int)
  13.          (signal 'interrupt i enabled-int))))
  14.  
  15. (define (initialize-interrupts!)
  16.   (set-interrupt-handlers! interrupt-handlers)
  17.   (set! one-second (time time-option/ticks-per-second #f))
  18.   (set-enabled-interrupts! all-interrupts))
  19.  
  20. (define time-option/ticks-per-second (enum time-option ticks-per-second))
  21. (define one-second #f)
  22.  
  23. (define no-interrupts 0)
  24.  
  25. (define all-interrupts (- (arithmetic-shift 1 interrupt-count) 1))
  26.  
  27. (define (with-interrupts-inhibited thunk)
  28.   (with-interrupts no-interrupts thunk))
  29.  
  30. (define (with-interrupts-allowed thunk)
  31.   (with-interrupts all-interrupts thunk))
  32.  
  33. (define (with-interrupts interrupts thunk)
  34.   ;; I might consider using dynamic-wind here, but (a) I'm worried
  35.   ;; about the speed of thread switching (which uses this) and (b)
  36.   ;; it's a pretty bad idea to throw in or out of one of these anyhow.
  37.   (let ((ei (set-enabled-interrupts! interrupts)))
  38.     (call-with-values thunk
  39.       (lambda results
  40.     (set-enabled-interrupts! ei)
  41.     (apply values results)))))
  42.  
  43. (define (enabled-interrupts)        ;For debugging
  44.   (let ((e (set-enabled-interrupts! 0)))
  45.     (set-enabled-interrupts! e)
  46.     e))
  47.  
  48.  
  49. ; Signal an interrupt if an insufficient amount of memory is reclaimed by
  50. ; a garbage collection.  The amount defaults to 10% of the heap.
  51.  
  52. (define (interrupt-before-heap-overflow! . maybe-required-space)
  53.   (let ((space (if (null? maybe-required-space)
  54.            (quotient (memory-status memory-status-option/heap-size 0)
  55.                  10)
  56.            (car maybe-required-space))))
  57.     (vector-set! interrupt-handlers
  58.          interrupt/memory-shortage
  59.          (lambda (ei)
  60.            (memory-status
  61.                 memory-status-option/set-minimum-recovered-space!
  62.             space)
  63.            (signal 'interrupt interrupt/memory-shortage ei)))
  64.     (memory-status memory-status-option/set-minimum-recovered-space!
  65.            space)))
  66.  
  67. (define interrupt/memory-shortage (enum interrupt memory-shortage))
  68. (define memory-status-option/set-minimum-recovered-space!
  69.   (enum memory-status-option set-minimum-recovered-space!))
  70. (define memory-status-option/heap-size
  71.   (enum memory-status-option heap-size))
  72.  
  73.